home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 1
/
Cream of the Crop 1.iso
/
EDUCATE
/
CATTEST.ARJ
/
EVAL3.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-12-19
|
15KB
|
454 lines
unit Eval3;
interface
uses Crt,Utility;
PROCEDURE Evaluate(VAR Formula: STRING; { Fomula to evaluate}
VAR Value: Real; { Result of formula }
VAR ErrPos: Integer;{ Position of error }
VAR ErrMsg: STRING); { Message of error }
implementation
PROCEDURE Evaluate(VAR Formula: STRING; { Fomula to evaluate}
VAR Value: Real; { Result of formula }
VAR ErrPos: Integer;{ Position of error }
VAR ErrMsg: STRING); { Message of error }
(* COMMENTS
1) modified IV/27/1990-does bracket checking internally
-does not allow alphabetic material in equations
-reports error kind as well as position
1 = brackets not balanced
2 = alphabetic in formula
V/29/1990-uses error message text.
*)
CONST
Numbers: SET OF Char = ['0'..'9','.'];
EofLine = ^M;
VAR
Position: Integer; { Current position in formula }
Ch: Char; { Current character being scanned }
k,
brkt_counter : Integer;
Formula_save : string;
{ Procedure NextCh returns the next character in the formula }
{ The variable Pos contains the position ann Ch the character }
{ eval.pas }
{ Evaluate an infix expression typed on the command line. Give no arguments
to get the help message. Bruce K. Hillyer.
This program is written for Microsoft pascal to use the REAL type,
which seems to avoid answers like 0.999999999999999 when the correct
answer is 1.
Note that some versions of Microsoft pascal incorrectly decide that your pc
has an 8087 or 80287 math coprocessor when in fact it doesn't. To check
this, try a simple multiplication. If eval 2*3 says 2, rather than 6,
set the enviornment variable set NO87=X in your autoexec.bat file.
This code is derived in part from the spreadsheet that comes with turbo
pascal, which contains the following message:
MICROCALC DEMONSTRATION PROGRAM Version 1.00A
This program is hereby donated to the public domain
for non-commercial use only. Dot commands are for
the program lister: LISTT.PAS (available with our
TURBO TUTOR): .PA, .CP20, etc...
}
TYPE
exprStr = STRING;
VAR
retnVl : REAL;
errLoc : INTEGER;
i : INTEGER;
{ functions for REAL }
(*
FUNCTION Andrqq( a : REAL) : REAL; { round }
FUNCTION Aidrqq( a : REAL) : REAL; { trunc }
FUNCTION Srdrqq( a : REAL) : REAL; { sqrt }
FUNCTION Sndrqq( a : REAL) : REAL; { sin }
FUNCTION Cndrqq( a : REAL) : REAL; { cos }
FUNCTION Tndrqq( a : REAL) : REAL; { tan }
FUNCTION Asdrqq( a : REAL) : REAL; { arcsin }
FUNCTION Acdrqq( a : REAL) : REAL; { arccos }
FUNCTION Atdrqq( a : REAL) : REAL; { arctan }
FUNCTION Shdrqq( a : REAL) : REAL; { sinh }
FUNCTION Chdrqq( a : REAL) : REAL; { cosh }
FUNCTION Thdrqq( a : REAL) : REAL; { tanh }
FUNCTION Lndrqq( a : REAL) : REAL; { ln }
FUNCTION Lddrqq( a : REAL) : REAL; { log }
FUNCTION Exdrqq( a : REAL) : REAL; { exp }
FUNCTION Pidrqq( a : REAL; b : INTEGER) : REAL; {power}
FUNCTION Prdrqq( a, b : REAL) : REAL; { power }
FUNCTION Mddrqq( a, b : REAL) : REAL; { mod }
FUNCTION Mndrqq( a, b : REAL) : REAL; { min }
FUNCTION Mxdrqq( a, b : REAL) : REAL; { max }
PROCEDURE Endxqq; { halt }
*)
PROCEDURE strToNum(formula : exprStr; start, len : INTEGER;
VAR retVal : REAL; VAR errPos : INTEGER);
VAR
tempStr : STRING;
i : INTEGER;
BEGIN
tempStr := COPY(formula,start,len);
WHILE (Length(tempStr) > 0 ) AND (tempStr[1] = ' ') DO
Delete(tempStr,1,1);
IF tempStr[1] = '.'
THEN Insert('0',tempStr,1);
IF tempStr[1] = '+'
THEN Delete(tempStr,1,1);
VAL(tempStr,retVal,errPos);
END; { strToNum }
PROCEDURE printNum(num : REAL);
VAR
pointLoc : INTEGER;
tempStr : STRING;
ErrPos : INTEGER;
BEGIN
IF (num = Round(num)) AND (num <= 1.0e17) THEN { integer }
BEGIN
STR(int(num):1:0,tempStr);
Writeln(tempStr)
END
ELSE IF Abs(num) > 1.0e6
THEN Writeln(num:24) { big float }
ELSE BEGIN
Str(Abs(num):1:16,tempStr);
{ the position of the decimal point is one more than the number
of digits in the absolute value of the integer part }
pointLoc := Pos('.',tempStr);
IF pointLoc = 0
THEN Writeln(output,num:1:0)
ELSE BEGIN
STR(num:1:(16-pointLoc),tempStr);
(* WHILE (Length(tempStr) > pointLoc) AND
(tempStr[Length(tempStr)] = '0') DO{};*)
Writeln(output,tempStr)
END
END
END; { printNum }
(*
PROCEDURE evaluate(formula : exprStr; VAR exprVl: REAL; VAR errPos: INTEGER);
{ evaluate the formula }*)
VAR
pos : INTEGER; { current position in formula }
function Min(x,y:real):real;
begin
if x>y then Min := y else Min := x;
end;
function Max(x,y:real):real;
begin
if x>y then Max := x else Max := y;
end;
PROCEDURE nextCh;
{ get the next character into ch, set pos, <cr> indicates eos }
BEGIN
REPEAT
pos := pos + 1;
IF pos <= Length(formula)
THEN ch := formula[pos]
ELSE ch := Chr(0)
UNTIL ch <> ' '
END; { nextCh }
FUNCTION expression : REAL;
VAR
e : REAL;
FUNCTION simpleExpression : REAL;
VAR
s : REAL;
FUNCTION term : REAL;
VAR
t,t2 : REAL;
FUNCTION signedFactor : REAL;
FUNCTION factor : REAL;
TYPE
builtin = (fabs, fround, ftrunc, fsqrt, fsqr, fsin, fcos, ftan,
farcsin, farccos, farctan, fsinh, fcosh, ftanh,
fln, flog, flog2, fexp, ffact);
builtinList = ARRAY[builtin] OF STRING;
CONST
builtinNames : (*builtinList*)
array[builtin] of string =
('abs', 'round', 'trunc', 'sqrt', 'sqr', 'sin', 'cos','tan'
,
'arcsin', 'arccos', 'arctan', 'sinh', 'cosh', 'tanh',
'ln', 'log', 'log2', 'exp', 'fact');
VAR
e,l : INTEGER; { intermediate variables }
found : BOOLEAN;
f : REAL;
fn : builtin;
start : INTEGER;
FUNCTION thisFn(inp : exprStr; pos : INTEGER; fn : builtin)
: BOOLEAN;
{ see if the input at location pos contains the fn name }
VAR
i : INTEGER;
BEGIN
thisFn := TRUE;
FOR i:=1 TO length(builtinNames[fn]) DO
IF inp[i+pos-1] <> builtinNames[fn,i]
THEN thisFn := FALSE
END; { thisFn }
FUNCTION factorial(arg : REAL): REAL;
BEGIN
arg := (*Andrqq*)Round(arg); { round it to avoid strangeness }
IF arg > 170
THEN
BEGIN
Writeln(output,'factorial: Too large argument');
exit;
END;
IF arg < 0
THEN
BEGIN
Writeln(output,'factorial: Negative argument');
exit;
END;
IF arg > 0
THEN factorial := arg * factorial(arg-1)
ELSE factorial := 1
END; { factorial }
FUNCTION log2( a : REAL) : REAL;
BEGIN
log2 := Ln(a) / Ln(2.0)
END; { log2 }
BEGIN { factor }
IF ((ch >= '0') AND (ch <= '9')) OR (ch = '.')
THEN
BEGIN
start := pos;
REPEAT
nextCh
UNTIL (ch < '0') OR (ch > '9');
IF ch = '.'
THEN
REPEAT
nextCh
UNTIL (ch < '0') OR (ch > '9');
strToNum(formula,start,pos-start,f,errPos)
END
ELSE IF ch='('
THEN
BEGIN
nextCh;
f := expression;
IF ch=')'
THEN nextCh
ELSE errPos := pos
END
ELSE
BEGIN { parse builtin function }
found := false;
(* FOR fn := Lower(fn) TO Upper(fn) DO*)
for fn := fabs to ffact do
IF NOT found
THEN
BEGIN { check this function name }
l := Length(builtinNames[fn]);
IF thisFn(formula,pos,fn)
THEN
BEGIN { call builtin }
pos := pos + l - 1;
nextCh;
f := factor;
CASE fn OF
fabs: f := Abs(f);
fround: f := round(f);
ftrunc: f := trunc(f);
fsqrt: f := Sqrt(f);
fsqr: f := f*f;
fsin: f := Sin(f);
fcos: f := Cos(f);
ftan: f := Sin(f)/Cos(f);
(* farcsin: f := Asdrqq(f);
farccos: f := Acdrqq(f);*)
farctan: f := ArcTan(f);
(*fsinh : f := Shdrqq(f);
fcosh : f := Chdrqq(f);
ftanh : f := Thdrqq(f);*)
fln : f := Ln(f);
flog: f := Ln(f)/2.303;
flog2: f := log2(f);
fexp: f := Exp(f);
ffact: f := factorial(f);
END; { CASE }
found := TRUE;
END; { call builtin }
END; { check this function name }
IF NOT found
THEN errPos := pos;
END; { parse builtin function }
factor := f
END; { factor }
BEGIN { signedFactor }
WHILE ch = ' ' DO
nextCh;
IF ch = '-'
THEN BEGIN
nextCh;
signedFactor := -factor
END
ELSE IF ch = '+'
THEN BEGIN
nextCh;
signedFactor := factor
END
ELSE signedFactor := factor
END; { signedFactor }
BEGIN { term }
t := signedFactor;
WHILE (ch = '^') AND (errPos = 0) DO {power}
BEGIN
nextCh;
t2 := signedFactor;
t := exp(t2*ln(t));
END;
term := t
END; { term }
BEGIN { simpleExpression }
s := term;
WHILE ((ch = '*') OR (ch = '/') OR (ch = '\') OR (ch = 'm'))
AND (errPos = 0) DO
IF ch = '/'
THEN BEGIN
nextCh;
s := s / term
END
ELSE IF ch = '*'
THEN BEGIN
nextCh;
s := s * term
END
(* ELSE IF ch = '\'
THEN BEGIN
nextCh;
s := s mod (term)
END *)
ELSE IF ch = 'm'
THEN
BEGIN
nextCh;
IF ch = 'i'
THEN BEGIN
nextCh;
IF ch = 'n'
THEN BEGIN
nextCh;
s := Min(s,(term))
END
ELSE errPos := pos
END
ELSE IF ch = 'a'
THEN BEGIN
nextCh;
IF ch = 'x'
THEN BEGIN
nextCh;
s := Max(s,(term))
END
ELSE errPos := pos
END
ELSE errPos := pos
END;
simpleExpression := s
END; { simpleExpression }
BEGIN { expression }
e := simpleExpression;
WHILE ((ch = '+') OR (ch = '-')) AND (errPos = 0) DO
IF ch = '-'
THEN BEGIN
nextCh;
e := e - simpleExpression
END
ELSE BEGIN
nextCh;
e := e + simpleExpression
END;
expression := e
END; { expression }
BEGIN { evaluate }
pos := 0;
ErrPos := 0;
nextCh;
Formula_save := Formula;
value := expression;
if pos < Length(Formula) then
begin
ErrPos := pos;
ErrMsg := 'BAD PARSE,->'+Formula_save;
end
else ErrMsg := OK_Message;
END; { evaluate }
END.
